Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/trans/transpar.frm

Text File | 1996-10-29 | 6KB | 144 lines

VERSION 4.00
Begin VB.Form Form1
   Caption         =   "Form1"
   ClientHeight    =   4800
   ClientLeft      =   3885
   ClientTop       =   2085
   ClientWidth     =   2730
   Height          =   5205
   Left            =   3825
   LinkTopic       =   "Form1"
   ScaleHeight     =   320
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   182
   Top             =   1740
   Width           =   2850
   Begin VB.CommandButton Command1
      Caption         =   "TransparentBlt"
      Height          =   375
      Left            =   360
      TabIndex        =   1
      Top             =   1920
      Width           =   1935
   End
   Begin VB.PictureBox Picture1
      AutoSize        =   -1  'True
      Height          =   960
      Left            =   360
      Picture         =   "Transparent sample.frx":0000
      ScaleHeight     =   60
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   120
      TabIndex        =   0
      Top             =   2400
      Width           =   1860
   End
End
Attribute VB_Name = "Form1"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit

Private Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type

Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Sub Command1_Click()
  Dim R As RECT
  With R
    R.Left = 20
    R.Top = 20
    R.Right = Picture1.ScaleWidth - 20
    R.Bottom = Picture1.ScaleHeight - 20
  End With
  TransparentBlt Form1.hdc, Form1.hdc, Picture1.hdc, R, 40, 40, vbWhite
End Sub


Private Sub TransparentBlt(OutDstDC, DstDC, SrcDC, SrcRect As RECT, DstX, DstY, TransColor As Long)
  'DstDC=Device context into which image must be drawn transparently
  'OutDstDC=Device context into image is actually drawn, even though it is made transparent in terms of DstDC
  'Src=Device context of source to be made transparent in color TransColor
  'SrcRect=rectangular region within SrcDC to be made transparent in terms of DstDC, and drawn to OutDstDC
  'DstX, DstY =coordinates in OutDstDC (and DstDC) where tranparent bitmap must go

  Rem In most cases, OutDstDC and DstDC will be the same

  Dim nRet As Long, W As Integer, H As Integer
  Dim MonoMaskDC As Long, hMonoMask As Long
  Dim MonoInvDC As Long, hMonoInv As Long
  Dim ResultDstDC As Long, hResultDst As Long
  Dim ResultSrcDC As Long, hResultSrc As Long
  Dim hPrevMask As Long, hPrevInv As Long, hPrevSrc As Long, hPrevDst As Long
  W = SrcRect.Right - SrcRect.Left + 1
  H = SrcRect.Bottom - SrcRect.Top + 1

  'create monochrome mask and inverse masks
  MonoMaskDC = CreateCompatibleDC(DstDC)
  MonoInvDC = CreateCompatibleDC(DstDC)
  hMonoMask = CreateBitmap(W, H, 1, 1, ByVal 0&)
  hMonoInv = CreateBitmap(W, H, 1, 1, ByVal 0&)
  hPrevMask = SelectObject(MonoMaskDC, hMonoMask)
  hPrevInv = SelectObject(MonoInvDC, hMonoInv)

  'create keeper DCs and bitmaps
  ResultDstDC = CreateCompatibleDC(DstDC)
  ResultSrcDC = CreateCompatibleDC(DstDC)
  hResultDst = CreateCompatibleBitmap(DstDC, W, H)
  hResultSrc = CreateCompatibleBitmap(DstDC, W, H)
  hPrevDst = SelectObject(ResultDstDC, hResultDst)
  hPrevSrc = SelectObject(ResultSrcDC, hResultSrc)

  'copy src to monochrome mask
  Dim OldBC As Long
  OldBC = SetBkColor(SrcDC, TransColor)
  nRet = BitBlt(MonoMaskDC, 0, 0, W, H, SrcDC, SrcRect.Left, SrcRect.Top, vbSrcCopy)
  TransColor = SetBkColor(SrcDC, OldBC)

  'create inverse of mask
  nRet = BitBlt(MonoInvDC, 0, 0, W, H, MonoMaskDC, 0, 0, vbNotSrcCopy)

  'get background
  nRet = BitBlt(ResultDstDC, 0, 0, W, H, DstDC, DstX, DstY, vbSrcCopy)
  'AND with Monochrome mask
  nRet = BitBlt(ResultDstDC, 0, 0, W, H, MonoMaskDC, 0, 0, vbSrcAnd)
  'get overlapper
  nRet = BitBlt(ResultSrcDC, 0, 0, W, H, SrcDC, SrcRect.Left, SrcRect.Top, vbSrcCopy)
  'AND with inverse monochrome mask
  nRet = BitBlt(ResultSrcDC, 0, 0, W, H, MonoInvDC, 0, 0, vbSrcAnd)
  'XOR these two
  nRet = BitBlt(ResultDstDC, 0, 0, W, H, ResultSrcDC, 0, 0, vbSrcInvert)

  'output results
  nRet = BitBlt(OutDstDC, DstX, DstY, W, H, ResultDstDC, 0, 0, vbSrcCopy)

  'clean up
  hMonoMask = SelectObject(MonoMaskDC, hPrevMask)
  DeleteObject hMonoMask
  hMonoInv = SelectObject(MonoInvDC, hPrevInv)
  DeleteObject hMonoInv
  hResultDst = SelectObject(ResultDstDC, hPrevDst)
  DeleteObject hResultDst
  hResultSrc = SelectObject(ResultSrcDC, hPrevSrc)
  DeleteObject hResultSrc
  DeleteDC MonoMaskDC
  DeleteDC MonoInvDC
  DeleteDC ResultDstDC
  DeleteDC ResultSrcDC


End Sub